home *** CD-ROM | disk | FTP | other *** search
/ Shareware Grab Bag / Shareware Grab Bag.iso / 001 / tmodem23.arc / BASIC.INC next >
Encoding:
Text File  |  1985-05-19  |  7.5 KB  |  310 lines
  1. (****************************************************************************)
  2. (*               BASIC Functions Programmed in Turbo PASCAL.                *)
  3. (****************************************************************************)
  4.  
  5.  
  6. (****************************************************************************)
  7. (*                              INKEY$                                      *)
  8. (****************************************************************************)
  9. type
  10.    kbdtype = string[2];
  11. function
  12.    inkey : kbdtype;
  13. var
  14.    a     : string[2];
  15.    ch    : char;
  16. begin
  17.    if keypressed then begin
  18.       read(kbd,ch);
  19.       a := ch;
  20.       if keypressed and (ch = #27) then begin
  21.          read(kbd,ch);
  22.          a := concat(a,ch);
  23.       end;
  24.    end
  25.    else
  26.       a := '';
  27.    inkey := a;
  28. end;
  29.  
  30. (****************************************************************************)
  31. (*                               STRING$                                    *)
  32. (****************************************************************************)
  33. function
  34.    bstring( n : integer; x : char ) : strtype;
  35. var
  36.    j    : integer;
  37.    y    : strtype;
  38. begin
  39.    y[0] := chr(n);
  40.    for j:=1 to n do y[j]:=x;
  41.    bstring := y;
  42. end;
  43.  
  44. (****************************************************************************)
  45. (*                                  VAL                                     *)
  46. (****************************************************************************)
  47. function
  48.    bval( x : strtype ) : integer;
  49. var
  50.    i,j,err,a : integer;
  51. begin
  52.    a := 0;
  53.    if length(x) > 0 then begin
  54.       i := 1;
  55.       while x[i] = ' ' do i := i+1;
  56.       j := length(x)-i+1;
  57.       val(copy(x,i,j),a,err);
  58.       if err > 1 then begin
  59.          j := err-1;
  60.          val(copy(x,i,j),a,err);
  61.       end;
  62.    end;
  63.    bval := a;
  64. end;
  65.  
  66. (****************************************************************************)
  67. (*                                   HEX$                                   *)
  68. (****************************************************************************)
  69. function
  70.    hex( n : integer ) : strtype;
  71. type
  72.    hexdigits  = 0..15;
  73.    hexarray   = array[hexdigits] of char;
  74. const
  75.    hextab : hexarray = ('0','1','2','3','4','5','6','7',
  76.                         '8','9','A','B','C','D','E','F');
  77. var
  78.    a      : string[4];
  79.    i,x    : integer;
  80. begin
  81.    x := n;
  82.    for i:=1 to 4 do begin
  83.       a := concat(hextab[x and $000F],a);
  84.       x := x shr 4;
  85.    end;
  86.    hex := a;
  87. end;
  88.  
  89. (****************************************************************************)
  90. (*                               INPUT                                      *)
  91. (****************************************************************************)
  92. procedure
  93.    str_input(var s : strtype);
  94. var
  95.    ix,iy,ip,hx : byte;
  96.    ins_mode    : boolean;
  97.    ich         : kbdtype;
  98.  
  99.    procedure
  100.       shape_cursor(st,en : integer);
  101.    type
  102.       registerpack = record
  103.                         AX,BX,CX,DX,BP,DI,SE,DS,ES,Flags : integer;
  104.                      end;
  105.    var
  106.       reg          : registerpack;
  107.       crtmode      : byte absolute $0040:$0049;
  108.    begin
  109.       if crtmode = 7 then begin
  110.          st := st + 5;
  111.          en := en + 5;
  112.       end;
  113.       reg.AX := $0100;
  114.       reg.CX := (st shl 8) + en;
  115.       intr($10,reg);
  116.    end;
  117.  
  118.    procedure
  119.       end_of_line(s : strtype);
  120.    begin
  121.       ix:=wherex+length(s)-ip+1;
  122.       ip:=length(s)+1;
  123.       gotoxy(ix,iy);
  124.    end;
  125.  
  126.    procedure
  127.       top_of_line;
  128.    begin
  129.       ip:=1;
  130.       gotoxy(hx,iy);
  131.    end;
  132.  
  133.    procedure
  134.       left_arrow;
  135.    begin
  136.       if ip>1 then begin
  137.          ip:=ip-1;
  138.          ix:=wherex-1;
  139.          gotoxy(ix,iy);
  140.       end;
  141.    end;
  142.  
  143.    procedure
  144.       right_arrow(s : strtype);
  145.    begin
  146.       if ip<=length(s) then begin
  147.          ip:=ip+1;
  148.          ix:=wherex+1;
  149.          gotoxy(ix,iy);
  150.       end;
  151.    end;
  152.  
  153.    procedure
  154.       del_char(var s : strtype);
  155.    var
  156.       i      : byte;
  157.    begin
  158.       if length(s)>0 then begin
  159.          if ip<=length(s) then begin
  160.             delete(s,ip,1);
  161.             ix:=wherex;
  162.             for i:=ip to length(s) do write(s[i]);
  163.             write(' ');
  164.             gotoxy(ix,iy);
  165.          end
  166.          else begin
  167.             ix:=wherex-1;
  168.             ip:=ip-1;
  169.             gotoxy(ix,iy);
  170.          end;
  171.       end;
  172.    end;
  173.  
  174.    procedure
  175.       erase_to_end(var s : strtype);
  176.    begin
  177.       while ip <= length(s) do del_char( s );
  178.    end;
  179.  
  180.    procedure
  181.       del_pre_char(var s : strtype);
  182.    begin
  183.       if ip>1 then begin
  184.          ip:=ip-1;
  185.          ix:=wherex-1;
  186.          gotoxy(ix,iy);
  187.          del_char(s);
  188.       end;
  189.    end;
  190.  
  191.    procedure
  192.       process_change(var s : strtype);
  193.    var
  194.       i     : byte;
  195.    begin
  196.       case ich[1] of
  197.          #210 : begin
  198.                    ins_mode := true;
  199.                    shape_cursor(1,7);
  200.                 end;
  201.          ^M   : ;
  202.          #199 : top_of_line;
  203.          #245 : erase_to_end(s);
  204.          #207 : end_of_line(s);
  205.          #211 : del_char(s);
  206.          ^H   : del_pre_char(s);
  207.          #205 : right_arrow(s);
  208.          #203 : left_arrow;
  209.       else
  210.          if ip<=length(s) then
  211.             s[ip] := ich
  212.          else
  213.             s := s+ich;
  214.          ip:=ip+1;
  215.          write(ich);
  216.       end;
  217.    end;
  218.  
  219.    procedure
  220.       process_insert(var s : strtype);
  221.    var
  222.       i            : byte;
  223.    begin
  224.       case ich[1] of
  225.          #210 : begin
  226.                    ins_mode := false;
  227.                    shape_cursor(6,7);
  228.                 end;
  229.          ^M   : ;
  230.          #199 : top_of_line;
  231.          #245 : erase_to_end(s);
  232.          #207 : end_of_line(s);
  233.          #211 : del_char(s);
  234.          ^H   : del_pre_char(s);
  235.          #205 : right_arrow(s);
  236.          #203 : left_arrow;
  237.       else
  238.          if ip>length(s) then begin
  239.             ip:=ip+1;
  240.             s:=s+ich;
  241.             write(ich);
  242.          end
  243.          else begin
  244.             insert(ich,s,ip);
  245.             ix:=wherex+1;
  246.             for i:=ip to length(s) do write(s[i]);
  247.             ip:=ip+1;
  248.             gotoxy(ix,iy);
  249.          end;
  250.       end;
  251.    end;
  252.  
  253. begin
  254.    ip:=1;
  255.    iy:=wherey;
  256.    hx:=wherex;
  257.    ins_mode:=false;
  258.    repeat
  259.       ich:=inkey;
  260.    until ich <> '';
  261.    repeat
  262.       if length(ich)=2 then ich:=chr(ord(ich[2])+128);
  263.       if ins_mode then
  264.          process_insert(s)
  265.       else
  266.          process_change(s);
  267.       if ich <> ^M then begin
  268.          repeat
  269.             ich:=inkey;
  270.          until ich <> '';
  271.       end;
  272.    until ich = ^M;
  273.    shape_cursor(6,7);
  274. end;
  275.  
  276. procedure
  277.    num_input( var i : integer );
  278. var
  279.    numstr : string[10];
  280. begin
  281.    str(i,numstr);
  282.    str_input(numstr);
  283.    i:=bval(numstr);
  284. end;
  285.  
  286. (****************************************************************************)
  287. (*                               UP CASE STRING                             *)
  288. (****************************************************************************)
  289. procedure
  290.    upstring( var s : strtype );
  291. var
  292.    i   : integer;
  293. begin
  294.    for i:=1 to length( s ) do
  295.       s[i] := upcase( s[i] );
  296. end;
  297.  
  298. (****************************************************************************)
  299. (*                      DETERMINE MEMORY AVAILABLE                          *)
  300. (****************************************************************************)
  301. function
  302.    memory   : integer;
  303. var
  304.    memspace : real;
  305. begin
  306.    memspace := maxavail;
  307.    if memspace < 0 then
  308.       memspace := 65536.0 + memspace;
  309.    memory := round( (memspace * 16.0) / 1024.0 );
  310. end;